{-# LANGUAGE EmptyDataDecls, MultiParamTypeClasses, RankNTypes, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving, ExistentialQuantification, RecordWildCards, ScopedTypeVariables, TupleSections, TypeOperators, FlexibleContexts, FunctionalDependencies #-}

--TODO: figure out compose arrow

module Main () where

import Sound.PortMidi -- cabal install PortMidi
import qualified Data.Heap as H -- cabal install heap
import qualified Data.DList as D -- cabal install dlist -w /usr/bin/ghc

import Data.List
import Data.Maybe
import Control.Concurrent
import System.Random

import qualified Data.Traversable as T (sequenceA,mapM)
import Control.Arrow
import Control.Applicative
import Control.Monad

import Control.Monad.Reader
import Control.Monad.Writer
import Control.Monad.State
import Control.Monad.Identity

main :: IO ()
main = do -- normally do something like the following in ghci
	x <- livecode	-- start threads
	ins x =<< minor -- add some generators
	ins x $ Kit 9   -- conventional drum channel
	pause 3

	ls x		-- view a list of them, remove one
	rm x 2
	ls x
	pause 3

	msg x 1 >>= doDisp
	msg x 1 >>= setKey 61 -- tell a generator to change state
	msg x 1 >>= doDisp
	pause 3

	stop x		-- stop threads

-- * composition algorithms

--type NoteGenerator = (MonadWriter Log m, MonadReader Context m, MonadIO m, Monad m, Functor m, Integral a) => a -> IntSupT m [Note] -- i think we can't use MonadSupply here cuz we didn't write all the MonadTrans instances
type NoteGenerator = Integral a => a -> IntSupT (LoggerT (CtxtRdrT IO)) [Note] -- the above version works except for the arrowified attempt to define compose below

data Gen = Minor { key :: MVar Int, junk :: String } 
	 | Kit Int 
	 deriving Show

class Disp g => Generator g where
	getComposer :: g -> NoteGenerator

instance Disp Gen where
	disp g@(Minor k j) = do s <- readMVar k
			        return $ show g ++ " key:" ++ show s
	disp g = return $ show g -- lame we can't reuse the default

instance Generator Gen where
	getComposer g@(Minor _ _) = doMinor g
	getComposer (Kit n)       = doKit n

minor :: IO Gen
minor = do k <- newMVar 60
	   return Minor {key = k, junk = "hi"}

setKey :: Integral a => a -> Gen -> IO ()
setKey n (Minor k j) = setMVar k $ fromIntegral n

doMinor :: Gen -> NoteGenerator
doMinor g m = mapM replaceNoteNum $ swingMeasure 0 m
    where replaceNoteNum x = do
	    k <- liftIO . readMVar $ key g
	    (Just o) <- untilM ((/= 0) . fromJust) (const $ (fmap signum) <$> snext) $ Just 0
	    (Just m) <- snext
            let nr :: (Real r) => (Note -> r) -> (Note -> Rational)
                nr = (toRational .)
                interval = getInterval (m + if odd (mod m $ length intervals) && (and . map (== 0) $ [nr beat, nr subdiv] <*> [x]) -- see discussion of why not to use existentials here http://tunes.org/~nef//logs/haskell/09.08.12
						then o -- on first beat of each measure play a chord tone
						else 0
				       ) intervals
            return $ x {midiNum = k + interval}

doKit :: Integral a => a -> NoteGenerator
doKit n = return . filter (\x -> or $ [(== 0) . subdiv , odd . beat] <*> return x) . swingMeasure n -- note currying away the measure argument means no accessing the transformer stack

-- * configuration

latencyMS     = 1 -- must be > 0, or portmidi ignores timestamps
myLatMS       = 1 -- the latency of our scheduler (events need to be added this far ahead of time in order to be output in order, otherwise they will just be emitted immediately)
measuresAhead = 1 -- how far ahead of the output the composer stays

tempo     = 200 -- bpm
timeSig   = TimeSig { numBeats = 4
                    , unit     = Quarter
                    }

intervals = [2,1,2,2,1,2,2] -- minor scale

noteRange = (-20,20)

-- * livecode infrastructure

-- cale @ #haskell suggested this structure
data LiveCode = LiveCode { 
	  stop  :: IO ()
        , start :: IO ()
	, ins   :: Gen -> IO () -- really want: Generator g => g -> IO ()
	, rm    :: Integral a => a -> IO ()
	, ls    :: IO ()
	, msg   :: Integral a => a -> IO Gen
	}

data State = Running | Stopping | Idle deriving (Eq, Show)

data Context = Context {
      queue         :: MVar PMQ
    , startTime     :: Real a => a
    , stream        :: Maybe (Either PMStream PMError)
    , stopNow       :: IO Bool
    , measureNum    :: IO Double -- really want: (Real a, Fractional a) => IO a
    , getGenerators :: IO [Gen] -- really want: (Generator g) => IO [g]
    }

livecode :: IO LiveCode
livecode = do
	state      <- newMVar Idle
	generators <- newMVar ([] :: [Gen]) -- really want ([] :: Generator g => [g])

	let x = LiveCode { stop = modifyMVar_ state $ \s ->
				if s == Running then putStrLn "OK stopping" >> return Stopping
						else do case s of Stopping -> putStrLn "already stopping" 
								  Idle     -> putStrLn "already stopped"
							return s
			 , start = modifyMVar_ state $ \s ->
				if s /= Idle then (putStrLn $ "busy " ++ show s) >> return s
					     else run
			 , ins = \g -> modifyMVar_ generators (\gs -> return (gs ++ [g]))
			 , rm  = \n -> modifyMVar_ generators (return . removeNth n)
			 , ls  = printNumberedList =<< readMVar generators
			 , msg = \n -> flip genericIndex (n-1) <$> (readMVar generators)
			 }
	    run = do
		pLog    <- newEmptyMVar :: IO (MVar (String,Log))
		cLog    <- newEmptyMVar :: IO (MVar (String,Log))
		measure <- newMVar $ realToFrac 0
		q       <- newMVar (H.empty :: PMQ)

		showResult initialize ("initializing... " ++)
		showResult countDevices $ ("found " ++) . (++ " devices")

		d <- getDefaultOutputDeviceID
		showResult (T.mapM getDeviceInfo d) (("default output is " ++ show d ++ ": ") ++)

		s <- T.mapM (flip openOutput latencyMS) d
		putStrLn $ "opening stream... " ++ show s

		t <- time -- must be evaluated after opening stream, which resets the counter!  portmidi.h says:
			  -- "If the application wants to use PortTime, it should start the timer (call Pt_Start) before calling Pm_OpenInput or Pm_OpenOutput."
			  -- but PortMidi.hs neither exposes Pt_Start nor calls it

		let logInContext log str flag w = (putMVar log =<< (str,) <$> runReaderT (execWriterT w) c) >> (debug flag Finishes . putStrLn $ "\n" ++ str ++ " done")
		    c = Context { queue         = q
				, startTime     = fromIntegral t
				, stream        = s
				, stopNow       = (/= Running) <$> readMVar state -- also safe to use (== Stopping), but will block til start has refilled the MVar with Running, so not necessary
				, measureNum    = readMVar measure
				, getGenerators = readMVar generators
				}
		forkIO . logInContext pLog "composer" composeDebug =<< (runRandomRIOT noteRange $ mapWhileM_ compose [0 ..])
		forkIO $ logInContext cLog "drain"    drainDebug      $ repeatWhileM_ (drain $ setMVar measure)
		forkIO $ do 
			mapM_ printLog [(composeDebug,pLog,id),(drainDebug,cLog,rebreak "measure")] -- a bit redundant to reexpress these relations, but if logInContext printed the logs, we'd have to mutex stdout, and it's this call that blocks until we're ready to close midi

			e <- useStream hasHostError (const $ return False) s
			when (fromMaybe False e) $ putStrLn "\n***PortMidi host error" -- PortMidi.hs doesn't expose Pm_GetHostErrorText()

			showResult (useStream close doError s) ("closing stream... " ++)
			showResult terminate $ ("terminating... " ++) . (++ "\ndone")
			setMVar state Idle
		return Running

	start x
	return x

-- * music util

data DurBase = Whole | Half | Quarter | Eighth | Sixteenth | ThirtySecond deriving (Enum, Bounded, Show, Eq)
data ModDur = forall x. NoteDur x => Dotted x | Triplet DurBase

data TimeSig = TimeSig {
      numBeats :: Int
    , unit     :: DurBase
    }

data Note = forall x . NoteDur x => Note {
      midiNum :: Int -- 0-255
    , vel     :: Int -- 0-255
    , chan    :: Int -- 0-15
    , measure :: Integral a => a
    , beat    :: Int
    , subdiv  :: (Real a, Fractional a) => a -- % of beat
    , dur     :: x
    }

swingMeasure :: (Integral a, Integral b) => a -> b -> [Note]
swingMeasure c m = [n {beat = b} | n <- [downbeat, changeDur downbeat {vel = 100, subdiv = 2/3} (Triplet Eighth)]
                                 , b <- [0 .. numBeats timeSig - 1]
                                 ]
	where downbeat = Note { midiNum = 60
			      , vel     = 75
			      , chan    = fromIntegral c
			      , measure = fromIntegral m
			      , beat    = 0
			      , subdiv  = 0
			      , dur     = Triplet Quarter
			      }

-- http://www.haskell.org/ghc/docs/6.12-latest/html/users_guide/release-6-12-1.html#id2887987
-- Record updates can now be used with datatypes containing existential type variables, provided the fields being altered do not mention the existential types.
changeDur :: (NoteDur b) => Note -> b -> Note -- would rather use existential record update syntax, but dur is existential
changeDur Note{..} d = Note {
	midiNum = midiNum
	, vel     = vel
	, chan    = chan
	, measure = measure
	, beat    = beat
	, subdiv  = subdiv -- realToFrac s
	, dur     = d
	}

class NoteDur a where
    quarters :: (Real x, Fractional x) => a -> x 
     
    calcDurMS :: (Real x, Fractional x) => a -> x
    calcDurMS d = 1000 * 60 * beats d / realToFrac tempo

    beats :: (Real x, Fractional x) => a -> x   
--    beats d = (quarters d) / (quarters $ unit timeSig) -- want to factor out the application of quarters
--    beats d = uncurry (/) $ join (***) quarters (d, unit timeSig) -- join (***) from Saizan_ @ #haskell, but isn't existentially polymorphic
    beats d = uncurry (/) $ both quarters (d, unit timeSig)
	where both (f :: forall a b. (NoteDur a, Real b, Fractional b) => a -> b) (x, y) = (f x, f y) -- lame that this has to be class specific (copumpkin @ #haskell says a 'forall classes' would be nice)

instance NoteDur DurBase where
    quarters x = z where Just z = lookup x . zip [minBound .. maxBound] $ map (fromRational . (2 ^^)) [2, 1 ..]

instance NoteDur ModDur where
{- why isn't something like this OK?  scree @ #haskell points out that if NoteDur were a type instead of a class it would work, but then we have to carry around another constructor (ie: NoteDur Dotted Eighth)
    quarters (x y) = quarters y * case x of
	Dotted  -> 3 / 2
    	Triplet -> 2 / 3
-}
    quarters (Dotted  x) = quarters x * 3 / 2
    quarters (Triplet x) = quarters x * 2 / 3

instance NoteDur Note where
     quarters Note{..} = quarters dur

getInterval :: Int -> [Int] -> Int
getInterval n is 
	| n >= 0    = d * (last s) + if m == 0 
					then 0 
				  	else s !! (m-1)
	| otherwise = getInterval (-n) . map (* (-1)) $ reverse is -- could avoid this reverse with some fold fu
	where (d,m) = divMod n $ length is
              s     = cumsum is

calcStartMS :: (Real a, Fractional a) => Note -> a
calcStartMS n = realToFrac (subdiv n + (fromIntegral $ (measure n * numBeats timeSig) + beat n)) * (calcDurMS $ unit timeSig)

measureMS :: (Real a, Fractional a) => a
measureMS = calcStartMS Note { measure = 1
			     , beat    = 0
			     , subdiv  = 0
			     , midiNum = undefined
                             , vel     = undefined
                             , chan    = undefined
                             , dur     = undefined :: DurBase -- ugh
                             }

-- * the producer thread

compose :: (Integral a) => a -> IntSupT (LoggerT (CtxtRdrT IO)) Bool
compose m = do
	debug composeDebug Loops . liftIO . putStr $ "c" ++ show m

	let get x     = liftIO =<< (lift $ asks x)
	    done      = get stopNow
            ready     = (> fromIntegral m - measuresAhead) <$> get measureNum
--	    remMS     = (measureMS *) <$> (((fromIntegral m - measuresAhead) -) <$> get measureNum) -- this doesn't seem to call measureNum each time it is accessed (would be nice cuz we could tune our wait times)
	    composers = fst <$> res
	    res       = unzip . map (getComposer &&& show) <$> get getGenerators -- any way to use disp instead of show, this would log the internal states of the generators instead of just their types.  but we don't want to log IO Stings...

	mapM (lift . tell' . (\s -> "\tcalling generator " ++ s ++ " measure: " ++ show m)) =<< (snd <$> res)

	g <- length <$> composers

        whileM_ ((not . or) <$> sequence [done,ready])                     $ (debug composeDebug Waits . liftIO $ putStr "cp:")                             >> (liftIO . pause $ measureMS/1000/2)
--      whileM_ ((not . or) <$> sequence [done,ready])                     $ (debug composeDebug Waits . (putStrLn . ("cp:" ++) . show) <$> get measureNum) >> (liftIO $ pause 10) -- doesn't print?  but does pause!  huh?
--	whileM_ ((not . or) <$> sequence [done,(> measureMS/2) <$> remMS]) $ (debug composeDebug Waits . (putStrLn . ("cp:" ++) . show) <$> remMS)          >> (liftIO $ pause 0.01) -- (pause . (/ (1000 * 2)) <$> remMS) -- no worky...

	ifM done (liftIO $ putStrLn "done making notes") $ do
		mapM_ (lift . lift . addNote) =<< concat <$> (composers >>= mapM ($ fromIntegral m)) -- thx dmwit @ #haskell for g >>= mapM ($ n)
		lift . tell' $ "done composing measure " ++ show m ++ " (" ++ show g ++ " generators)"

	not <$> done

--minimal example of above solution that works (in case we need to ask for help on #haskell)
compose' :: IntSupT (LoggerT (CtxtRdrT IO)) ()
compose' = do
	let get x = liftIO =<< (lift $ asks x)
	    res   = unzip . map (getComposer &&& show) <$> get getGenerators

	mapM (lift . tell') =<< (snd <$> res)
        
	mapM_ (lift . lift . addNote) =<< concat <$> (fst <$> res >>= mapM ($ 1))

{-
--desired fully arrowified example that doesn't work
compose'' :: IntSupT (LoggerT (CtxtRdrT IO)) ()
compose'' = do
	let get x = liftIO =<< (lift $ asks x)
	    both   = (\g -> mapM_ (lift . lift . addNote) =<< getComposer g 1) 
			&&& 
		     (lift . tell' . show)

	map both <$> get getGenerators
	return ()
-}

--if getComposer is both sides of the arrow, it compiles, but not if both sides are show
--note the getComposer version only works if we use the specific version of the definition of NoteGenerator above (type NoteGenerator = Integral a => a -> IntSupT (LoggerT (CtxtRdrT IO)) [Note]) 
compose'' :: IntSupT (LoggerT (CtxtRdrT IO)) ()
compose'' = do
	let get x = liftIO =<< (lift $ asks x)
	    both   = (\g -> mapM_ (lift . lift . addNote) =<< getComposer g 1) 
			&&& 
		     (\g -> mapM_ (lift . lift . addNote) =<< getComposer g 1) 
{-	    other  = (lift . tell' . show)
			&&& 
		     (lift . tell' . show)
-}
	g <- length <$> map both <$> get getGenerators
--	map other <$> get getGenerators
	return ()

-- * our scheduler ensures we send monotonic increasing timestamps to portmidi

-- igel @ #haskell (Data.Heap's author) agrees there's no way to reuse MinPolicy here -- HeapItem MinPolicy a is already defined for all a
-- edward says it might have been possible for him to use a class that would let us override it
data PMPol
instance H.HeapItem PMPol PMEvent where
    newtype H.Prio PMPol PMEvent = PMP (Integer,Integer) deriving (Eq, Ord) -- velocity is 2nd component of ordering so noteoffs happen before noteons
    type    H.Val  PMPol PMEvent = PMMsg

    split x = ( PMP ( fromIntegral $ timestamp x
                    , fromIntegral . data2 $ message x
                    )
              , message x
              )
    merge (PMP x,y) = PMEvent { timestamp = fromIntegral $ fst x
                              , message   = y
                              }

type PMQ = H.Heap PMPol PMEvent

-- because a noteOff event in midi turns off a note no matter how many previous noteOns occurred, 
-- we need to be careful to not schedule a noteOff during a previously scheduled note, and remove 
-- any previously scheduled noteOff that would prematurely cut off the new note.  the alg is a little 
-- tricky and it would be nice to "prove" its correctness -- and there are enough degrees of freedom 
-- that QuickCheck would not explore the relevant corner cases.  how would one approach this from a 
-- curry-howard perspective?  i think the invariant is that there are never two noteOffs in a row.
-- also, any way to decompose this better?
addNote :: Note -> CtxtRdrT IO ()
addNote n = do
    t <- asks startTime

    let start      = PMEvent { message   = noteOn
                             , timestamp = startT
                             }
        end        = PMEvent { message   = noteOff
                             , timestamp = endT
                             }
        startT     = t + (round $ calcStartMS n)
	endT       = startT + (round $ calcDurMS n)
	unInt      = fromInteger . fromIntegral
        noteOn     = PMMsg { status = unInt $ onCode + chan n
                           , data1  = unInt $ midiNum n
                           , data2  = unInt $ vel n
                           }
        noteOff    = noteOn {data2 = 0}
	onCode     = 0x90
	maybeEnd q = if overlap . span ((endT >) . timestamp) . H.toAscList . fst $ H.partition match q -- break the schedule of events with the same midiNum and channel into (before endT,same time as or after endT)
		     	then []                                                       -- we don't add a noteoff when it occurs during a previously existing note
		     	else [end] 
        match      = (\m -> data1 m == (unInt $ midiNum n)                            -- find events with the same midiNum and channel -- how avoid calculating this twice for each element 
										      -- (once in the partition and once in the filter)?
			     && 
			    (status m) - unInt onCode == (unInt $ chan n)
		     ) . message 
	isNoteOff  = (0 ==) . data2 . message
	notDuring  = or . ([(endT <=),(startT >)] <*>) . return . timestamp           -- remove any previously existing noteOff that will occur after startT and before (or simultaneous with) endT
		      &&& 
		     not . and . ([match, isNoteOff] <*>) . return                    -- only noteOffs for the matching midiNum and channel can be filtered out
		      >>^ uncurry (||)
	overlap    = fromMaybe False . fmap (not . isNoteOff) . maybeLast             -- we do not schedule a noteOff if the first thing before us is a noteOn
		      ***
		     or . catMaybes . (([fmap] <*> [isNoteOff,(endT ==) . timestamp]) <*>) . return . listToMaybe -- or if the first thing after us is a noteOff (implying we overlapped with an ongoing note) 
		      >>^ uncurry (||)										-- note we fail to return to the original velocity.  also omit our noteOff if a noteOn or noteOff 
														-- was already scheduled at the same time.  there is one failure condition 
														-- when there is nothing before us and a noteOn after us, there may be a note currently playing 
														-- and we've missed its noteOn (we assume this isn't the case; to fix, we'd have to keep a 
														-- synchronized list of currently playing notes, each with a stack of their velocities)
		      
    when (startT < endT) $ asksTo modifyMVar_ queue $ \q -> return
							    $ foldl (flip H.insert) (H.filter notDuring q) -- not sure the foldl is wise, especially since insert looks designed for foldr, but we know we're 
													   -- dealing with a finite list...
							    $ start : maybeEnd q      -- would it be more efficient to insert in a different order?

-- * the consumer thread

-- any way to decompose this better?
drain :: (Real a, Fractional a) => (a -> IO ()) -> LoggerT (CtxtRdrT IO) Bool
drain setMeasureNum = do
    debug drainDebug Loops . liftIO $ putStr "d"

    s  <- asks stream
    t  <- liftIO time
    st <- asks startTime
    done <- liftIO =<< asks stopNow

    let cleanup nq str del next = return (nq, (str, next, del, done && H.null nq))
	m = (fromIntegral $ t - st) / measureMS

    liftIO $ setMeasureNum m
    debug drainDebug Waits . liftIO . putStrLn $ show m

    (str, next, del, out) <- lift . asksTo modifyMVar queue $ \q ->

        case H.view q of
            Nothing          -> cleanup q (Just "q empty") (not done) Nothing
            Just (next,rest) -> do
		e <- liftIO $ useStream hasHostError (const $ return True) s
                if ts <= myLatMS + t || fromMaybe True e
                   then cleanup rest (Just rpt) False $ Just next
                   else cleanup q    Nothing    True    Nothing
                where ts  = timestamp next
                      rpt =    "measure: "
			    ++ (shown 10 m)
			    ++ "   \ttimestamp: "
                            ++ (show ts)
                            ++ "   \tvel: "
                            ++ (show . data2 $ message next)
                            ++ "   \t("
                            ++ (show $ H.size rest)
                            ++ " evts left) "
		      shown d n = if (elem '.' q) then q else x
			where x = show n
			      q = if notElem 'e' x
					then take d $ x ++ (if (elem '.' x) then "" else ".") ++ repeat '0'
					else x

    maybe (return ()) tell' str

    T.mapM doEvent next
    when del $ tell' "." >> liftIO (pause $ toRational myLatMS / 1000) >> (debug drainDebug Waits . liftIO $ putStr "pd")
    return $ not out

doEvent :: PMEvent -> LoggerT (CtxtRdrT IO) ()
doEvent e = do
    s <- asks stream
    mapWriterT lift $ logResult (useStream (flip writeEvents [e]) return s) ("writing event... " ++)

-- * supply util

-- adapted from http://www.haskell.org/haskellwiki/New_monads/MonadSupply
-- hides implementation, handles finite supplies, includes function to get multiple items
-- much taken from RWH's Supply monad in ch. 15: http://book.realworldhaskell.org/read/programming-with-monads.html#id646649
-- transformer in ch. 18: http://book.realworldhaskell.org/read/monad-transformers.html#monadtrans.maybet

newtype SupplyT s m a = ST (StateT [s] m a) deriving (Functor, Monad, MonadTrans, MonadIO)
newtype Supply s a = S (SupplyT s Identity a) deriving (Monad, Functor, MonadSupply s)

class (Monad m, Functor m) => MonadSupply s m | m -> s where -- mm_freak @ #haskell suggested i don't need this fundep, and it does work without it...  why did i have it?  
    snext  :: m (Maybe s)
    snext  =  head <$> snexts 1
    snexts,snexts' :: Integral a => a -> m [Maybe s]

instance (Monad m, Functor m) => MonadSupply s (SupplyT s m) where
    snexts n = ST $ do -- blackh @ #haskell's solution, cleaner than my Kleislis
	(these,rest) <- genericSplitAt n <$> get
	put rest
	return . genericTake n $ map Just these ++ repeat Nothing
    snexts' n = ST $ genericSplitAt n <$> get >>=
		        runKleisli (fst ^<< Kleisli (return . genericTake n . (++ repeat Nothing) . map Just)
		 	                     *** 
			 	            Kleisli put) -- put requires that we Kleisli, because it is s -> m()

runSupply :: Supply s a -> [s] -> (a, [s])
runSupply (S m) = runIdentity . runSupplyT m

runSupplyT :: Functor m => SupplyT s m a -> [s] -> m (a, [s])
runSupplyT (ST s) = runStateT s

evalSupply :: Supply s a -> [s] -> a
evalSupply (S s) = runIdentity . evalSupplyT s

evalSupplyT :: (Functor m) => SupplyT s m a -> [s] -> m a
evalSupplyT = (fst <$>) `dot` runSupplyT

-- * random util

randomsRIO :: Random a => (a,a) -> IO [a] -- note System.Random is known to be very slow, but this application isn't very demanding (see discussion here, incl pointers to nonuniform distributions: http://www.serpentine.com/blog/2009/09/19/a-new-pseudo-random-number-generator-for-haskell/)
randomsRIO lims = getStdRandom $ first (randomRs lims) . split

runRandomRIO :: (Random s) => (s, s) -> Supply s a -> IO a
runRandomRIO r s = evalSupply s <$> randomsRIO r

runRandomRIOT :: (Functor m, Random s) => (s, s) -> SupplyT s m a -> IO (m a)
runRandomRIOT r s = evalSupplyT s <$> randomsRIO r

-- * general util

maybeLast :: [a] -> Maybe a
maybeLast [] = Nothing
maybeLast x  = Just $ last x

cumsum :: Num a => [a] -> [a]
cumsum = scanl1 (+)

removeNth :: Integral n => n -> [a] -> [a]
removeNth n = map snd . (filter ((/= n) . fst)) . zip [1 ..]

rebreak :: Eq a => [a] -> [[a]] -> [[a]]
rebreak w = snd . foldr (\x (working,done) -> let result = x ++ working in 
				if (isPrefixOf w x) then ([]     , result : done) 
						    else (result , done)) 
			([],[])

-- from http://www.haskell.org/haskellwiki/Pointfree#Dot
-- note (f `dot` g) x = f . g x (http://stackoverflow.com/questions/907306/confusion-about-currying-and-point-free-style-in-haskell)
-- also known as blackbird, spectacles, or `oo` http://hackage.haskell.org/packages/archive/data-aviary/0.2.3/doc/html/Data-Aviary.html#v%3Aoo (see thread including http://osdir.com/ml/haskell-cafe@haskell.org/2010-02/msg00721.html)
dot :: (c -> d) -> (a -> b -> c) -> a -> b -> d
dot = (.) . (.)

-- from http://www.haskell.org/pipermail/beginners/2009-January/000690.html (via byorgey @ #haskell)
untilM :: (Monad m) => (a -> Bool) -> (a -> m a) -> a -> m a
untilM p f x | p x       = return x
             | otherwise = f x >>= untilM p f

mapWhileM_ :: (Monad m) => (a -> m Bool) -> [a] -> m ()
mapWhileM_ f []     = return ()
mapWhileM_ f (x:xs) = ifM (f x) (mapWhileM_ f xs) $ return ()

-- from http://hackage.haskell.org/package/monad-loops
whileM_ :: (Monad m) => m Bool -> m a -> m ()
whileM_ p f = do
        x <- p
        if x then do f
                     whileM_ p f
             else return ()

-- from http://hackage.haskell.org/package/yjtools
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM p t e = do b <- p
               if b then t else e

repeatWhileM_ :: (Monad m) => m Bool -> m ()
repeatWhileM_ f = ifM f (repeatWhileM_ f) $ return ()

pause :: (Real a, Fractional a) => a -> IO ()
pause = threadDelay . round . (* 1000000) . realToFrac -- threadDealy's resolution looks to be 10ms, seems very large?  (seems ~2x better in 6.12?)

setMVar :: MVar a -> a -> IO ()
setMVar v = modifyMVar_ v . const . return

-- from ski @ #haskell (see http://tunes.org/~nef//logs/haskell/09.08.06)
-- avoids nesting liftIO's, which gives a compiler error, when one wants more than one MVar from a ReaderT simultaneously using form:
-- asks selector >>= liftIO . (flip xxxMVar) (\x ->
asksTo :: (Monad m) => (a -> (a3 -> m1 a2) -> m a1) -> (r -> a) -> (a3 -> ReaderT r m1 a2) -> ReaderT r m a1
asksTo wrap sel body = do
    mv <- asks sel
    ReaderT $ \r ->
        wrap mv $ (`runReaderT` r) . body

-- * application specific util

type LogItem = String
type Log = D.DList LogItem -- cuz []'s have slow (++) http://book.realworldhaskell.org/read/programming-with-monads.html#monadcase.writer.dlist
type CtxtRdrT = ReaderT Context
type LoggerT = WriterT Log 
type IntSupT = SupplyT Int -- why doesn't this work:  (Integral a) => SupplyT a 

tell' ::  (Monad m) => LogItem -> LoggerT m ()
tell' = debug (maximum [composeDebug,drainDebug]) Log . tell . D.singleton -- how design this so we don't have to explicitly list them all and don't redundantly encode the order with the debug function?

logResult :: Show a => (IO a) -> (String -> String) -> LoggerT IO ()
logResult f g = tell' =<< g . show <$> liftIO f

showResult :: Show a => (IO a) -> (String -> String) -> IO ()
showResult f g = putStrLn . g . show =<< f

class Show s => Disp s where
	disp :: s -> IO String
	disp = return . show

instance Show (MVar Int) where 
	show = const "Mvar Int"

doDisp :: Disp d => d -> IO ()
doDisp d = putStrLn =<< disp d

printNumberedList :: Disp s => [s] -> IO ()
printNumberedList = mapM_ (\(n,g) -> putStrLn =<< ((show n ++ " - ") ++) <$> disp g) . (zip [1 ..])

doError :: PMError -> IO PMError
doError x = putStr "\n***" >> getErrorText x >>= putStrLn >> return x

-- the most beautiful line of code i've ever written
useStream :: (PMStream -> IO a) -> (b -> IO a) -> Maybe (Either PMStream b) -> IO (Maybe a)
useStream = T.sequenceA `dot` fmap `dot` (|||)

-- * debug infrastructure

data Debug = Off | Log | Finishes | Loops | Waits deriving (Ord, Eq)

composeDebug = Off
drainDebug = Off

printLog :: (Debug,MVar (String,Log),([LogItem] -> [LogItem])) -> IO ()
printLog (really,v,f) = do
	(s,log) <- readMVar v -- unconditional cuz callers depend on us to block til the log is ready (readMVar blocks even if we don't use the contents)
	debug really Log $ do
		putStrLn $ s ++ " log:"
		mapM_ putStrLn . f $ D.toList log

debug :: (Monad m) => Debug -> Debug -> m () -> m ()
debug = when `dot` (>=)